home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue35 / construc / TBOBSMTP.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1998-06-18  |  3.6 KB  |  135 lines
  1. unit TBOBSMTP;
  2. {$DEFINE DEBUG}
  3. interface
  4. uses
  5.   Classes, ScktComp;
  6.  
  7. type
  8.   TBSMTP = class(TComponent)
  9.   public
  10.     constructor Create(AOwner: TComponent); override;
  11.     destructor Destroy; override;
  12.   public
  13.     procedure SendMail;
  14.   protected
  15.     _Socket: TClientSocket;
  16.     Step: Integer;
  17.     procedure SocketRead(Sender: TObject; Socket: TCustomWinSocket);
  18.     procedure SocketWrite(Sender: TObject; Socket: TCustomWinSocket);
  19.   private
  20.     fMailServer: String;
  21.     fMessageTo: String; { only one "To" at a time }
  22.     fMessageFrom: String;
  23.     fMessageSubject: String;
  24.     fMessageText: TStringList; { assign to TMemo.Lines for example }
  25.     procedure SetMessageText(NewText: TStringList);
  26.   published
  27.     property MailServer: String read fMailServer write fMailServer;
  28.     property MessageTo: String read fMessageTo write fMessageTo;
  29.     property MessageFrom: String read fMessageFrom write fMessageFrom;
  30.     property MessageSubject: String read fMessageSubject write fMessageSubject;
  31.     property MessageText: TStringList read fMessageText write SetMessageText;
  32.   end;
  33.  
  34. implementation
  35. uses
  36.   SysUtils, Forms; { for the Application.ProcessMessages-loop }
  37.  
  38. constructor TBSMTP.Create(AOwner: TComponent);
  39. begin
  40.   inherited Create(AOwner);
  41.   _Socket := TClientSocket.Create(Self);
  42.   _Socket.Port := 25; // according to RFC 821
  43.   _Socket.OnRead := SocketRead;
  44.   _Socket.OnWrite := SocketWrite;
  45.   Step := 0;
  46.   fMessageText := TStringList.Create
  47. end {Create};
  48.  
  49. destructor TBSMTP.Destroy;
  50. begin
  51.   fMessageText.Free;
  52.   _Socket.Free;
  53.   _Socket := nil;
  54.   inherited Destroy
  55. end {Destroy};
  56.  
  57. procedure TBSMTP.SetMessageText(NewText: TStringList);
  58. begin
  59.   fMessageText.Assign(NewText)
  60. end {SetMessageText};
  61.  
  62. procedure TBSMTP.SocketRead(Sender: TObject; Socket: TCustomWinSocket);
  63. var
  64.   Status: String;
  65. begin
  66.   Status := Socket.ReceiveText;
  67. {$IFDEF DEBUG}
  68.   writeln(Status);
  69. {$ENDIF}
  70.   SocketWrite(Sender, Socket)
  71. end {SocketRead};
  72.  
  73. procedure TBSMTP.SocketWrite(Sender: TObject; Socket: TCustomWinSocket);
  74. const
  75.   CRLF = #13#10;
  76. var
  77.   i: Integer;
  78.   Send: String;
  79. begin
  80.   Inc(Step);
  81.   case Step of
  82.     1: Send := 'HELO ' + fMessageFrom;
  83.     2: Send := 'MAIL FROM:' + fMessageFrom;
  84.     3: Send := 'RCPT TO:' + fMessageTo;
  85.     4: Send := 'RCPT TO:bob@bolesian.nl'; { always a copy to myself }
  86.     5: Send := 'DATA';
  87.     6: begin
  88.        {$IFDEF DEBUG}
  89.          writeln('From: ' + fMessageFrom);
  90.        {$ENDIF}
  91.          Socket.SendText('From: ' + fMessageFrom + CRLF);
  92.        {$IFDEF DEBUG}
  93.          writeln('To: ' + fMessageTo);
  94.        {$ENDIF}
  95.          Socket.SendText('To: ' + fMessageTo + CRLF);
  96.        {$IFDEF DEBUG}
  97.          writeln('Cc: bob@bolesian.nl');
  98.        {$ENDIF}
  99.          Socket.SendText('Cc: bob@bolesian.nl' + CRLF);
  100.        {$IFDEF DEBUG}
  101.          writeln('Subject: ' + fMessageSubject + CRLF);
  102.        {$ENDIF}
  103.          Socket.SendText('Subject: ' + fMessageSubject + CRLF + CRLF);
  104.          for i:=0 to Pred(fMessageText.Count) do
  105.          begin
  106.            Send := fMessageText[i];
  107.          {$IFDEF DEBUG}
  108.            writeln(Send);
  109.          {$ENDIF}
  110.            Socket.SendText(Send + CRLF)
  111.          end;
  112.          Send := '.'
  113.        end;
  114.     7: Send := 'QUIT'
  115.   end;
  116. {$IFDEF DEBUG}
  117.   writeln(Send);
  118. {$ENDIF}
  119.   Socket.SendText(Send + CRLF)
  120. end {SocketWrite};
  121.  
  122. procedure TBSMTP.SendMail;
  123. begin
  124.   Step := 0;
  125.   _Socket.Active := False;
  126.   _Socket.Host := fMailServer;
  127.   _Socket.Open;
  128.   repeat
  129.   { need to rewrite this using low-level Windows APIs }
  130.     Application.ProcessMessages
  131.   until Step > 7
  132. end {SendMail};
  133.  
  134. end.
  135.